home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / forth / amiga / amigaker.arc / 11.number < prev    next >
Text File  |  1987-12-30  |  13KB  |  340 lines
  1. ;
  2. ;  11.number
  3. ;
  4. ;  Number input, output, and conversion.
  5.  
  6.  
  7. * digit           (s char base -- n true | char false ) Converts char if
  8. ; in correct base, to number n.
  9.                   dc.w     -1
  10.                   dc.l     link0
  11. link0             set      *-4
  12.                   dc.b     $85,'digi',$80!'t'
  13.                   cnop     0,2
  14. _digit            dc.l     *+4
  15.                   movem.l  (sp),d0-d1
  16.                   subi.b   #'0',d1
  17.                   bpl.s    1$
  18.                   bra      no
  19. 1$                cmpi.b   #10,d1
  20.                   bcs.s    2$
  21.                   subq.b   #7,d1
  22.                   cmpi.b   #10,d1
  23.                   bcs      no
  24. 2$                cmp.b    d1,d0
  25.                   bls      no
  26.                   move.l   d1,4(sp)
  27.                   bra      yes
  28.  
  29. * double?         (s -- fl ) Returns true if period encountered in input.
  30.                   dc.w     -1
  31.                   dc.l     link0
  32. link0             set      *-4
  33.                   dc.b     $87,'double',$80!'?'
  34.                   cnop     0,2
  35. _double_question  dc.l     nest
  36.                   dc.l     _dpl,_fetch,_1_plus,_0_notequal,_exit
  37.  
  38. * convert         (s ud1 addr1 -- ud2 addr2 ) Starting with unsigned d1
  39. ; convert string at addr1 to d2 and leave unconvertable string addr2.
  40.                   dc.w     -1
  41.                   dc.l     link3
  42. link3             set      *-4
  43.                   dc.b     $87,'conver',$80!'t'
  44.                   cnop     0,2
  45. _convert          dc.l     nest
  46. 1$                dc.l     _1_plus,_dup,_to_r
  47.                   dc.l     _c_fetch,_base,_fetch,_digit
  48.                   dc.l     _question_branch,2$
  49.                   dc.l     _swap,_base,_fetch,_um_times,_drop
  50.                   dc.l     _rot,_base,_fetch,_um_times,_d_plus
  51.                   dc.l     _double_question,_question_branch,3$
  52.                   dc.l     _1,_dpl,_plus_store
  53. 3$                dc.l     _r_from,_branch,1$
  54. 2$                dc.l     _drop,_r_from,_exit
  55.  
  56. * (number?)       (s addr -- d flag ) Convert string at addr to a number.
  57. ; NOTE: the end of the string is found by checking for the terminating
  58. ; null.
  59.                   dc.w     -1
  60.                   dc.l     link0
  61. link0             set      *-4
  62.                   dc.b     $89,$28,'number?',$80!$29
  63.                   cnop     0,2
  64. _nest_number_question
  65.                   dc.l     nest
  66.                   dc.l     _0,_0,_rot,_dup,_1_plus,_c_fetch
  67.                   dc.l     _nest_lit,'-',_equals,_dup,_to_r,_minus
  68.                   dc.l     _dpl,_on
  69. 1$                dc.l     _convert,_dup,_c_fetch,_nest_lit,','
  70.                   dc.l     _nest_lit,'/',_between
  71.                   dc.l     _question_branch,2$
  72.                   dc.l     _dpl,_off
  73.                   dc.l     _branch,1$
  74. 2$                dc.l     _minus_rot
  75.                   dc.l     _r_from,_question_branch,3$
  76.                   dc.l     _dnegate
  77. 3$                dc.l     _rot,_c_fetch,_0_equal,_exit
  78.  
  79. * number?         (s addr -- d flag ) Convert string into a number, observes
  80. ; a minus sign, sets dpl to position of a delimiter, String must end in a
  81. ; null.
  82.                   dc.w     -1
  83.                   dc.l     link2
  84. link2             set      *-4
  85.                   dc.b     $87,'number',$80!'?'
  86.                   cnop     0,2
  87. _number_question  dc.l     nest
  88.                   dc.l     _false,_over,_count,_bounds
  89.                   dc.l     _nest_question_do,2$
  90. 1$                dc.l     _i,_c_fetch,_base,_fetch,_digit,_nip
  91.                   dc.l     _question_branch,3$
  92.                   dc.l     _drop,_true,_nest_leave
  93. 3$                dc.l     _nest_loop,1$
  94. 2$                dc.l     _question_branch,4$
  95.                   dc.l     _nest_number_question,_branch,5$
  96. 4$                dc.l     _drop,_0,_0,_false
  97. 5$                dc.l     _exit
  98.  
  99. * (number)        (s addr -- d ) Converts the string to a double number. The
  100. ; string must be null terminated, regards a minus sign and stores the
  101. ; decimal point location in dpl.
  102. ; Normally this word is the end of the search for a match in the current
  103. ; vocabulary. Then if it is not a number the word '?missing' is run,
  104. ; printing a message on the screen.
  105.                   dc.w     -1
  106.                   dc.l     link0
  107. link0             set      *-4
  108.                   dc.b     $88,$28,'number',$80!$29
  109.                   cnop     0,2
  110. _nest_number      dc.l     nest
  111.                   dc.l     _number_question,_not,_question_missing
  112.                   dc.l     _exit
  113.  
  114. * number          Deferred word, usually set to (number)
  115.                   dc.w     -1
  116.                   dc.l     link2
  117. link2             set      *-4
  118.                   dc.b     $86,'numbe',$80!'r'
  119.                   cnop     0,2
  120. _number           dc.l     dodefer,_nest_number
  121.  
  122. * hold            (s char -- ) Stores a character in a temporary storage
  123. ; space pointed to by hld. Stores characters in stack like format.
  124.                   dc.w     -1
  125.                   dc.l     link0
  126. link0             set      *-4
  127.                   dc.b     $84,'hol',$80!'d'
  128.                   cnop     0,2
  129. _hold             dc.l     nest
  130.                   dc.l     _minus_1,_hld,_plus_store
  131.                   dc.l     _hld,_fetch,_c_store,_exit
  132.  
  133. * <#              (s -- ) Sets hld to a storage space, currently pad, which
  134. ; is 160 bytes above here. Prepares for number to string conversion.
  135.                   dc.w     -1
  136.                   dc.l     link0
  137. link0             set      *-4
  138.                   dc.b     $82,$3C,$80!$23
  139.                   cnop     0,2
  140. _less_sharp       dc.l     nest
  141.                   dc.l     _pad,_hld,_store
  142.                   dc.l     _exit
  143.  
  144. * #>              (s d# -- addr len ) Ends number conversion, returns the
  145. ; address and the length of the string.
  146.                   dc.w     -1
  147.                   dc.l     link3
  148. link3             set      *-4
  149.                   dc.b     $82,$23,$80!$3e
  150.                   cnop     0,2
  151. _sharp_greater    dc.l     nest
  152.                   dc.l     _2drop,_hld,_fetch,_pad,_over,_minus
  153.                   dc.l     _exit
  154.  
  155. * sign            (s n -- ) Stores a minus sign at hld.
  156.                   dc.w     -1
  157.                   dc.l     link3
  158. link3             set      *-4
  159.                   dc.b     $84,'sig',$80!'n'
  160.                   cnop     0,2
  161. _sign             dc.l     nest
  162.                   dc.l     _0_less,_question_branch,1$
  163.                   dc.l     _nest_lit,'-',_hold
  164. 1$                dc.l     _exit
  165.  
  166. * #               (s d# -- d# ) converts a single digit in the current base
  167.                   dc.w     -1
  168.                   dc.l     link3
  169. link3             set      *-4
  170.                   dc.b     $81,$80!$23
  171.                   cnop     0,2
  172. _sharp            dc.l     nest
  173.                   dc.l     _base,_fetch,_um_divide_mod,_rot
  174.                   dc.l     _nest_lit,9,_over,_less_than
  175.                   dc.l     _question_branch,1$,_nest_lit,7,_plus
  176. 1$                dc.l     _nest_lit,'0',_plus,_hold,_exit
  177.  
  178. * #S              (s d# -- d# ) Converts an entire number.
  179.                   dc.w     -1
  180.                   dc.l     link3
  181. link3             set      *-4
  182.                   dc.b     $82,$23,$80!'S'
  183.                   cnop     0,2
  184. _sharp_s          dc.l     nest
  185. 1$                dc.l     _sharp,_2dup,_or,_0_equal
  186.                   dc.l     _question_branch,1$
  187.                   dc.l     _exit
  188.  
  189. * hex             Sets number base to 16
  190.                   dc.w     -1
  191.                   dc.l     link0
  192. link0             set      *-4
  193.                   dc.b     $83,'he',$80!'x'
  194.                   cnop     0,2
  195. _hex              dc.l     nest
  196.                   dc.l     _nest_lit,16,_base,_store,_exit
  197.  
  198. * decimal         Sets number base to 10, the default.
  199.                   dc.w     -1
  200.                   dc.l     link0
  201. link0             set      *-4
  202.                   dc.b     $87,'decima',$80!'l'
  203.                   cnop     0,2
  204. _decimal          dc.l     nest
  205.                   dc.l     _nest_lit,10,_base,_store,_exit
  206.  
  207. * octal           Sets number base to 8
  208.                   dc.w     -1
  209.                   dc.l     link3
  210. link3             set      *-4
  211.                   dc.b     $85,'octa',$80!'l'
  212.                   cnop     0,2
  213. _octal            dc.l     nest
  214.                   dc.l     _nest_lit,8,_base,_store,_exit
  215.  
  216. * binary          Sets number base to 2.
  217.                   dc.w     -1
  218.                   dc.l     link2
  219. link2             set      *-4
  220.                   dc.b     $86,'binar',$80!'y'
  221.                   cnop     0,2
  222. _binary           dc.l     nest
  223.                   dc.l     _2,_base,_store,_exit
  224.  
  225. * (u.)            (s u -- a l ) Converts unsigned number to a string
  226.                   dc.w     -1
  227.                   dc.l     link0
  228. link0             set      *-4
  229.                   dc.b     $84,$28,'u',$2E,$80!$29
  230.                   cnop     0,2
  231. _nest_u_dot       dc.l     nest
  232.                   dc.l     _0,_less_sharp,_sharp_s,_sharp_greater,_exit
  233.  
  234. * u.              (s u -- ) Prints output number and a trailing space.
  235.                   dc.w     -1
  236.                   dc.l     link1
  237. link1             set      *-4
  238.                   dc.b     $82,'u',$80!$2E
  239.                   cnop     0,2
  240. _u_dot            dc.l     nest
  241.                   dc.l     _nest_u_dot,_type,_space,_exit
  242.  
  243. * u.r             (s u l -- ) Prints unsigned number in a field of l spaces
  244. ; right justified.
  245.                   dc.w     -1
  246.                   dc.l     link1
  247. link1             set      *-4
  248.                   dc.b     $83,'u.',$80!'r'
  249.                   cnop     0,2
  250. _u_dot_r          dc.l     nest
  251.                   dc.l     _to_r,_nest_u_dot,_r_from,_over
  252.                   dc.l     _minus,_spaces,_type,_exit
  253.  
  254. * (.)             (s n -- a l ) Convert signed number to a string.
  255.                   dc.w     -1
  256.                   dc.l     link0
  257. link0             set      *-4
  258.                   dc.b     $83,'(.',$80!')'
  259.                   cnop     0,2
  260. _nest_dot         dc.l     nest
  261.                   dc.l     _dup,_abs,_0,_less_sharp,_sharp_s
  262.                   dc.l     _rot,_sign,_sharp_greater,_exit
  263.  
  264. * .               (s n -- ) Prints signed number and a trailing space.
  265.                   dc.w     -1
  266.                   dc.l     link2
  267. link2             set      *-4
  268.                   dc.b     $81,$80!$2e
  269.                   cnop     0,2
  270. _dot              dc.l     nest
  271.                   dc.l     _nest_dot,_type,_space,_exit
  272.  
  273. * .r              (s n l -- ) Print right justified signed number.
  274.                   dc.w     -1
  275.                   dc.l     link2
  276. link2             set      *-4
  277.                   dc.b     $82,$2E,$80!'r'
  278.                   cnop     0,2
  279. _dot_r            dc.l     nest
  280.                   dc.l     _to_r,_nest_dot,_r_from,_over,_minus
  281.                   dc.l     _spaces,_type,_exit
  282.  
  283. * (ud.)           (s ud -- a l ) Converts unsigned double into a string.
  284.                   dc.w     -1
  285.                   dc.l     link0
  286. link0             set      *-4
  287.                   dc.b     $85,'(ud.',$80!')'
  288.                   cnop     0,2
  289. _nest_ud_dot      dc.l     nest
  290.                   dc.l     _less_sharp,_sharp_s,_sharp_greater,_exit
  291.  
  292. * ud.             (s ud -- ) prints unsigned double and trailing space
  293.                   dc.w     -1
  294.                   dc.l     link1
  295. link1             set      *-4
  296.                   dc.b     $83,'ud',$80!'.'
  297.                   cnop     0,2
  298. _ud_dot           dc.l     nest
  299.                   dc.l     _nest_ud_dot,_type,_space,_exit
  300.  
  301. * ud.r            (s ud l -- ) prints unsigned double right justified
  302.                   dc.w     -1
  303.                   dc.l     link1
  304. link1             set      *-4
  305.                   dc.b     $84,'ud.',$80!'r'
  306.                   cnop     0,2
  307. _ud_dot_r         dc.l     nest
  308.                   dc.l     _to_r,_nest_ud_dot,_r_from,_over
  309.                   dc.l     _minus,_spaces,_type,_exit
  310.  
  311. * (d.)            (s d -- a l ) Convert signed double to a string.
  312.                   dc.w     -1
  313.                   dc.l     link0
  314. link0             set      *-4
  315.                   dc.b     $84,'(d.',$80!'r'
  316.                   cnop     0,2
  317. _nest_d_dot       dc.l     nest
  318.                   dc.l     _tuck,_dabs,_less_sharp,_sharp_s
  319.                   dc.l     _rot,_sign,_sharp_greater,_exit
  320.  
  321. * d.              (s d -- ) Print signed double followed by a space.
  322.                   dc.w     -1
  323.                   dc.l     link0
  324. link0             set      *-4
  325.                   dc.b     $82,'d',$80!'.'
  326.                   cnop     0,2
  327. _d_dot            dc.l     nest
  328.                   dc.l     _nest_d_dot,_type,_space,_exit
  329.  
  330. * d.r             (s d -- ) print signed double right justified.
  331.                   dc.w     -1
  332.                   dc.l     link0
  333. link0             set      *-4
  334.                   dc.b     $83,'d.',$80!'r'
  335.                   cnop     0,2
  336. _d_dot_r          dc.l     nest
  337.                   dc.l     _to_r,_nest_d_dot,_r_from,_over
  338.                   dc.l     _minus,_spaces,_type,_exit
  339.  
  340.